home *** CD-ROM | disk | FTP | other *** search
/ Point Programming 1 / PPROG1.ISO / pascal / swag / textfile.swg / 0012_DUPLICATE LINES (TEXT).pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-17  |  3.4 KB  |  127 lines
  1. Hi! Someone was needing help speeding up a duplicate line finder.
  2. Here is what I came up with (it's tested, TP 6.0)
  3. It needs the txtSeek unit I'm also posting here. I converted txtSeek
  4. from some code I found here (written in German), hope that person
  5. doesn't mind...
  6.  
  7. {D-,I-,L-,R-,X+}
  8. unit TxtSeek;
  9. interface
  10.  
  11.  function TextFilePos(var f:text):LongInt;         {FilePos}
  12.  function TextFileSize(var f:text):LongInt;        {FileSize}
  13.  procedure TextSeek(var f:text;Pos:LongInt);       {Seek}
  14.  procedure TextSeekRel(var f:text; Count:Longint); {Relative Seek}
  15.  
  16. implementation
  17. uses dos;
  18.  
  19. const
  20.  sAbs=0;     { for use with DosSeek }
  21.  sRel=1;
  22.  sEnd=2;
  23.  
  24. function DosSeek(handle:word; posn:LongInt; func:byte):longint;assembler;asm
  25.  mov ah,$42; mov al,func; mov bx,handle;
  26.  mov dx,word ptr posn; mov cx,word ptr posn+2; int $21;
  27.  jnc @S; mov inOutRes,ax; xor ax,ax; xor dx,dx; @S:
  28.  end;
  29.  
  30. function TextFilePos(var f:text):LongInt;begin
  31.  textFilePos:=DosSeek(Textrec(f).handle,0,sRel)
  32.                -TextRec(f).BufEnd+TextRec(f).BufPos;
  33.  end;
  34.  
  35. function TextFileSize(var f:text):LongInt;var Temp:LongInt;begin
  36.  case TextRec(f).Mode of
  37.   fmInput:with Textrec(f) do begin
  38.            Temp:=DosSeek(handle, 0, sRel);
  39.            textFileSize:=DosSeek(handle, 0, sEnd);
  40.            DosSeek(handle, Temp, sAbs);
  41.            end;
  42.   fmOutput:textFileSize:=TextFilePos(f);
  43.   else begin
  44.    textFileSize:=0;
  45.    InOutRes:=1;
  46.    end;
  47.   end;
  48.  end;
  49.  
  50. procedure TextSeek(var f:text; Pos:LongInt);begin
  51.  dosSeek(textRec(f).handle, pos, sAbs);
  52.  textRec(f).bufPos:=textRec(f).bufEnd;  {force read}
  53.  end;
  54.  
  55. procedure TextSeekRel(var f:text; Count:LongInt);begin
  56.  dosSeek(textRec(f).handle, count, sRel);
  57.  textRec(f).bufPos:=textRec(f).bufEnd;  {force read}
  58.  end;
  59.  
  60. end.
  61.  
  62. <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
  63.  
  64. {$A-,B-,D-,E-,F-,G+,I-,L-,N-,O-,R-,S-,V-,X+}
  65. {$M $800,$8000,$8000} {require heap memory}
  66. Uses Crt,txtSeek;
  67.  
  68. type bufType=array[0..32767] of char;  {try this, it's a nice round binary #}
  69. Var
  70.  buff:^bufType;
  71.  f, f2:Text;
  72.  looking,s,parm:String[80];
  73.  n,siz:Longint;
  74.  dupes:word;
  75.  
  76. Procedure CheckError(Err:integer); Begin
  77.  TextColor(12);
  78.  Case Err Of
  79.   -1: WriteLn('You must specify a file on the command line.');
  80.   2: WriteLn('Can''t find "', parm,'"');
  81.   4: WriteLn('Too many open files to open ', parm);
  82.   3,5..162: WriteLn('Error in reading ', parm);
  83.   End;
  84.  if err<>0 then begin WriteLn; Halt(1);end;
  85.  End;
  86.  
  87. Begin
  88.  If Paramcount<1 Then CheckError(-1);
  89.  parm:=paramstr(1);
  90.  Assign(f,parm);
  91.  New(buff);
  92.  SetTextBuf(f,buff^);
  93.  Reset(f);
  94.  checkError(IoResult);
  95.  Assign(f2,'FINDDUPE.$$$');
  96.  ReWrite(f2);
  97.  checkError(IoResult);
  98.  siz:=textFileSize(f);
  99.  Writeln('Deleting duplicate lines');
  100.  write('  0% complete');
  101.  n := 0;
  102.  dupes:=0;
  103.  Reset(f);
  104.  While not eof(f) Do Begin
  105.   Readln(f,Looking);
  106.   n:=textFilePos(f);
  107.   repeat
  108.    Readln(f, s);
  109.    until (s=looking) or eof(f);
  110.   if eof(f)then writeln(f2, looking) else inc(dupes);
  111.   Write(^M,(n*100)div siz:3);
  112.   textSeek(f, n);
  113.   End;
  114.  Close(f);
  115.  erase(f);   {erase original file}
  116.  Close(f2);
  117.  rename(f2,parm);  {rename temp file on top of it}
  118.  dispose(buff);
  119.  writeln(^M'Found ',dupes,' duplicates');
  120.  End.
  121.  
  122.  
  123.  * OLX 2.2 * This tagline was created with 100% recycled electrons...
  124.  
  125. --- Maximus 2.01wb
  126.  * Origin: >>> Sun Mountain BBS <<< (303)-665-6922 (1:104/123)
  127.